home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / c / num_pred.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-05-07  |  3.7 KB  |  235 lines
  1. /*
  2.  Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
  3.  
  4. This file is part of GNU Common Lisp, herein referred to as GCL
  5.  
  6. GCL is free software; you can redistribute it and/or modify it under
  7. the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
  8. the Free Software Foundation; either version 2, or (at your option)
  9. any later version.
  10.  
  11. GCL is distributed in the hope that it will be useful, but WITHOUT
  12. ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  13. FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
  14. License for more details.
  15.  
  16. You should have received a copy of the GNU Library General Public License 
  17. along with GCL; see the file COPYING.  If not, write to the Free Software
  18. Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20. */
  21.  
  22. /*
  23.     Predicates on numbers
  24. */
  25. #include "include.h"
  26. #include "num_include.h"
  27. #include "mp.h"
  28.  
  29. number_zerop(x)
  30. object    x;
  31. {
  32.     switch (type_of(x)) {
  33.  
  34.     case t_fixnum:
  35.         if (fix(x) == 0)
  36.             return(1);
  37.         else
  38.             return(0);
  39.  
  40.     case t_bignum:
  41.     case t_ratio:
  42.         return(0);
  43.  
  44.     case t_shortfloat:
  45.         if (sf(x) == 0.0)
  46.             return(1);
  47.         else
  48.             return(0);
  49.  
  50.     case t_longfloat:
  51.         if (lf(x) == 0.0)
  52.             return(1);
  53.         else
  54.             return(0);
  55.  
  56.     case t_complex:
  57.         return(number_zerop(x->cmp.cmp_real) &&
  58.                number_zerop(x->cmp.cmp_imag));
  59.  
  60.     default:
  61.         FEwrong_type_argument(Snumber, x);
  62.     }
  63. }
  64.  
  65. number_plusp(x)
  66. object    x;
  67. {
  68.     switch (type_of(x)) {
  69.  
  70.     case t_fixnum:
  71.         if (fix(x) > 0)
  72.             return(1);
  73.         else
  74.             return(0);
  75.  
  76.     case t_bignum:
  77.         if (big_sign(x) > 0)
  78.             return(1);
  79.         else
  80.             return(0);
  81.  
  82.     case t_ratio:
  83.         if (number_plusp(x->rat.rat_num))
  84.             return(1);
  85.         else
  86.             return(0);
  87.  
  88.     case t_shortfloat:
  89.         if (sf(x) > 0.0)
  90.             return(1);
  91.         else
  92.             return(0);
  93.  
  94.     case t_longfloat:
  95.         if (lf(x) > 0.0)
  96.             return(1);
  97.         else
  98.             return(0);
  99.  
  100.     default:
  101.         FEwrong_type_argument(TSor_rational_float);
  102.     }
  103. }
  104.  
  105. number_minusp(x)
  106. object    x;
  107. {
  108.     switch (type_of(x)) {
  109.  
  110.     case t_fixnum:
  111.         if (fix(x) < 0)
  112.             return(1);
  113.         else
  114.             return(0);
  115.  
  116.     case t_bignum:
  117.         if (big_sign(x) < 0)
  118.             return(1);
  119.         else
  120.             return(0);
  121.  
  122.     case t_ratio:
  123.         if (number_minusp(x->rat.rat_num))
  124.             return(1);
  125.         else
  126.             return(0);
  127.  
  128.     case t_shortfloat:
  129.         if (sf(x) < 0.0)
  130.             return(1);
  131.         else
  132.             return(0);
  133.  
  134.     case t_longfloat:
  135.         if (lf(x) < 0.0)
  136.             return(1);
  137.         else
  138.             return(0);
  139.  
  140.     default:
  141.         FEwrong_type_argument(TSor_rational_float);
  142.     }
  143. }
  144.  
  145. number_oddp(x)
  146. object x;
  147. {
  148.     int    i;
  149.  
  150.     if (type_of(x) == t_fixnum)
  151.         i = fix(x);
  152.     else if (type_of(x) == t_bignum)
  153.        i = MP_LOW(MP(x),lgef(MP(x)));
  154.     else
  155.         FEwrong_type_argument(Sinteger, x);
  156.     return(i & 1);
  157. }
  158.  
  159. number_evenp(x)
  160. object x;
  161. {
  162.     int    i;
  163.  
  164.     if (type_of(x) == t_fixnum)
  165.         i = fix(x);
  166.     else if (type_of(x) == t_bignum)
  167.       i = MP_LOW(MP(x),lgef(MP(x)));
  168.     else
  169.         FEwrong_type_argument(Sinteger, x);
  170.     return(~i & 1);
  171. }
  172.  
  173. Lzerop()
  174. {
  175.     check_arg(1);
  176.     check_type_number(&vs_base[0]);
  177.     if (number_zerop(vs_base[0]))
  178.         vs_base[0] = Ct;
  179.     else
  180.         vs_base[0] = Cnil;
  181. }
  182.  
  183. Lplusp()
  184. {
  185.     check_arg(1);
  186.     check_type_or_rational_float(&vs_base[0]);
  187.     if (number_plusp(vs_base[0]))
  188.         vs_base[0] = Ct;
  189.     else
  190.         vs_base[0] = Cnil;
  191. }
  192.  
  193. Lminusp()
  194. {
  195.     check_arg(1);
  196.     check_type_or_rational_float(&vs_base[0]);
  197.     if (number_minusp(vs_base[0]))
  198.         vs_base[0] = Ct;
  199.     else
  200.         vs_base[0] = Cnil;
  201. }
  202.  
  203. Loddp()
  204. {
  205.     check_arg(1);
  206.     check_type_integer(&vs_base[0]);
  207.     if (number_oddp(vs_base[0]))
  208.         vs_base[0] = Ct;
  209.     else
  210.         vs_base[0] = Cnil;
  211. }
  212.  
  213. Levenp()
  214. {
  215.     check_arg(1);
  216.     check_type_integer(&vs_base[0]);
  217.     if (number_evenp(vs_base[0]))
  218.         vs_base[0] = Ct;
  219.     else
  220.         vs_base[0] = Cnil;
  221. }
  222.  
  223. init_num_pred()
  224. {
  225.            big_register_1 = alloc_object(t_bignum);
  226.     ZERO_BIG(big_register_1);
  227.  
  228.     enter_mark_origin(&big_register_1);
  229.     make_function("ZEROP", Lzerop);
  230.     make_function("PLUSP", Lplusp);
  231.     make_function("MINUSP", Lminusp);
  232.     make_function("ODDP", Loddp);
  233.     make_function("EVENP", Levenp);
  234. }
  235.